home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / oasis / oasisegs.lha / egs / mmul.lisp < prev    next >
Lisp/Scheme  |  1992-04-23  |  2KB  |  59 lines
  1. (proclaim '(type fixnum           *n*))
  2. (proclaim '(type (array fixnum 2) *a*))
  3. (proclaim '(type (array fixnum 2) *b*))
  4. (proclaim '(type (array fixnum 2) *c*))
  5.  
  6. (proclaim '(function gen ((array fixnum 2) fixnum) nil))
  7.  
  8. (defvar *n* 64)
  9. (defvar *a* (make-array (cons *n* (cons *n* nil))
  10.             :element-type 'fixnum
  11.             :initial-element 0))
  12. (defvar *b* (make-array (cons *n* (cons *n* nil))
  13.             :element-type 'fixnum
  14.             :initial-element 0))
  15. (defvar *c* (make-array (cons *n* (cons *n* nil))
  16.             :element-type 'fixnum
  17.             :initial-element 0))
  18.  
  19. (defun run (m)
  20.        (declare (type fixnum m))
  21.        (do ((k m (- k 1)))
  22.            ((zerop k) nil)
  23.            (declare (type fixnum k))
  24.            (gen *a* *n*)
  25.            (gen *b* *n*)
  26.            (mmul) ))
  27.  
  28. (defun mmul ()
  29.        (do ((i 0 (+ i 1)))
  30.            ((= i *n*) nil)
  31.            (declare (type fixnum i))
  32.            (do ((j 0 (+ j 1)))
  33.                ((= j *n*) nil)
  34.                (declare (type fixnum j))
  35.                (do ((k 0 (+ k 1))
  36.                     (sum 0) )
  37.                    ((= k *n*) (setf (aref *c* i j) sum))
  38.                    (declare (type fixnum k)
  39.                             (type fixnum sum) )
  40.                    (setf sum (+ sum (* (aref *a* i k) (aref *b* k j)))) ))))
  41.  
  42. (defun gen (mat n)
  43.        (declare (type (array fixnum 2) mat)
  44.                 (type fixnum n) )
  45.        (let ((seed 197)
  46.              (b 0) )
  47.             (declare (type fixnum seed)
  48.                      (type fixnum b) )
  49.             (do ((i 0 (+ i 1)))
  50.                 ((= i n))
  51.                 (declare (type fixnum i))
  52.                 (do ((j (+ i 1) (+ j 1)))
  53.                     ((= j n))
  54.                     (declare (type fixnum j))
  55.                     (setf seed (rem (+ (* 4757 seed) 1) 32768))
  56.                     (setf b (+ 1 (rem (truncate (/ seed 16)) 256)))
  57.                     (setf (aref mat i j) b)
  58.                     (setf (aref mat j i) b) ))))
  59.